Gold Medal Software 1/Gold Medal Software Volume 1 (Gold Medal) (1994).iso/prog/tpwprog7.arj/MDIBITS.PAS

Pascal/Delphi Source File | 1992-07-02 | 5.7 KB | 210 lines

{ mdibits.pas -- MDI bitmap viewer }

program MDIBits;

{$R mdibits.res}

uses WinTypes, WinProcs, WObjects, WinDos, Strings, StdDlgs, UBitmap;

const

  id_Menu = 'MDIMenu';    { Menu resource ID }
  posWindowMenu = 1;      { Position of Window menu in menu bar }

type

  MDIBitsApplication = object(TApplication)
    procedure InitMainWindow; virtual;
  end;

  PMDIBitsWindow = ^TMDIBitsWindow;
  TMDIBitsWindow = object(TMDIWindow)
    constructor Init(ATitle: PChar; AMenu: HMenu);
    procedure MDIFileOpen(var Msg: TMessage);
      virtual cm_First + cm_MDIFileOpen;
  end;

  PBitmapChild = ^TBitmapChild;
  TBitmapChild = object(TWindow)
    Bitmap: HBitmap;          { Handle to bitmap in memory }
    Width, Height: LongInt;   { Size of bitmap image }
    IconBitmap: HBitmap;      { Handle to iconicized bitmap }
    IWidth, IHeight: LongInt; { Size of iconicized bitmap }
    constructor Init(AParent: PWindowsObject; ATitle: PChar;
      Handle: HBitmap; W, H: LongInt);
    destructor Done; virtual;
    function GetClassName: PChar; virtual;
    procedure GetWindowClass(var AWndClass: TWndClass); virtual;
    procedure AdjustScroller;
    procedure MakeIconBitmap(DC: HDC);
    procedure Paint(PaintDC: HDC;
      var PaintInfo: TPaintStruct); virtual;
    procedure WMSize(var Msg: TMessage);
      virtual wm_First + wm_Size;
  end;


{ TMDIBitsWindow }

{- Construct frame window }
constructor TMDIBitsWindow.Init(ATitle: PChar; AMenu: HMenu);
begin
  TMDIWindow.Init(ATitle, AMenu);
  ChildMenuPos := posWindowMenu
end;

{- Respond to File:Open command. Create new child window. }
procedure TMDIBitsWindow.MDIFileOpen(var Msg: TMessage);
var
  FileName: array[0 .. fsPathName] of Char;
  Bitmap: HBitmap;         { Handle to bitmap }
  Width, Height: LongInt;  { Bitmap's width and height in pixels }
begin
  StrCopy(FileName, '*.bmp');
  if Application^.ExecDialog(New(PFileDialog, Init(@Self,
    PChar(sd_FileOpen), FileName))) = id_Ok then
  begin
    SetCursor(LoadCursor(0, idc_Wait));
    Bitmap := LoadBitmap(FileName, HWindow, Width, Height);
    SetCursor(LoadCursor(0, idc_Arrow));
    if Bitmap = 0 then
      MessageBox(HWindow, 'File is not a bitmap', 'Error',
        mb_IconExclamation or mb_ok)
    else
      Application^.MakeWindow(New(PBitmapChild,
        Init(@Self, FileName, Bitmap, Width, Height)))
  end
end;


{ TBitmapChild }

{- Construct child window }
constructor TBitmapChild.Init(AParent: PWindowsObject; ATitle: PChar;
  Handle: HBitmap; W, H: LongInt);
begin
  TWindow.Init(AParent, ATitle);
  Attr.Style := Attr.Style or ws_VScroll or ws_HScroll;
  Bitmap := Handle;
  IconBitmap := 0;   { Created on first use }
  Width := W;
  Height := H;
  Scroller := New(PScroller, Init(@Self, 1, 1, 200, 200))
end;

{- Destroy child window }
destructor TBitmapChild.Done;
begin
  if Bitmap <> 0 then DeleteObject(Bitmap);
  TWindow.Done
end;

{- Modify child's window class to paint icon windows. }
procedure TBitmapChild.GetWindowClass(var AWndClass: TWndClass);
begin
  TWindow.GetWindowClass(AWndClass);
  AWndClass.HIcon := 0
end;

{- Give the new window class a name }
function TBitmapChild.GetClassName: PChar;
begin
  GetClassName := 'TBitmapClass'
end;

{- Keep scroll bars in synch with bitmap and window sizes }
procedure TBitmapChild.AdjustScroller;
var
  ClientRect: TRect;
begin
  GetClientRect(HWindow, ClientRect);
  with ClientRect do
    Scroller^.SetRange(Width - (Right - Left),
      Height - (Bottom - Top));
  InvalidateRect(HWindow, nil, true)
end;

{- Respond to changes in window size }
procedure TBitmapChild.WMSize(var Msg: TMessage);
begin
  TWindow.WMSize(Msg);
  if not (Msg.WParam = sizeIconic) then
    AdjustScroller
end;

{- Create a small bitmap for the window's icon }
procedure TBitmapChild.MakeIconBitmap(DC: HDC);
var
  MemDC1, MemDC2: HDC;
  OldBitmap1, OldBitmap2: HBitmap;
  R: TRect;
begin
  MemDC1 := CreateCompatibleDC(DC);
  MemDC2 := CreateCompatibleDC(DC);
  GetClientRect(HWindow, R);
  IWidth := R.Right;
  IHeight := R.Bottom;
  IconBitmap := CreateCompatibleBitmap(DC, IWidth, IHeight);
  OldBitmap1 := SelectObject(MemDC1, IconBitmap);
  OldBitmap2 := SelectObject(MemDC2, Bitmap);
  StretchBlt(MemDC1, 0, 0, IWidth, IHeight,
    MemDC2, 0, 0, Width, Height, SRCCopy);
  SelectObject(MemDC1, OldBitmap1);
  SelectObject(MemDC2, OldBitmap2);
  DeleteDC(MemDC1);
  DeleteDC(MemDC2)
end;

{- Paint bitmap inside window }
procedure TBitmapChild.Paint(PaintDC: HDC;
  var PaintInfo: TPaintStruct);
var
  MemDC: HDC;
  Image, OldBitmap: HBitmap;
  W, H: LongInt;
begin
  TWindow.Paint(PaintDC, PaintInfo);
  if IsIconic(HWindow) then
  begin
    if IconBitmap = 0 then MakeIconBitmap(PaintDC);
    Image := IconBitmap; W := IWidth; H := IHeight
  end else
  begin
    Image := Bitmap; W := Width; H := Height
  end;
  if Image <> 0 then
  begin
    MemDC := CreateCompatibleDC(PaintDC);
    OldBitmap := SelectObject(MemDC, Image);
    BitBlt(PaintDC, 0, 0, W, H, MemDC, 0, 0, SRCCopy);
    SelectObject(MemDC, OldBitmap);
    DeleteDC(MemDC)
  end
end;


{ MDIBitsApplication }

{- Initialize MDIBitsApplication object's window }
procedure MDIBitsApplication.InitMainWindow;
begin
  MainWindow := New(PMDIBitsWindow, Init('MDI Bitmap Viewer',
    LoadMenu(HInstance, id_Menu)))
end;

var

  MDIBitsApp: MDIBitsApplication;

begin
  MDIBitsApp.Init('MDIBitsApp');
  MDIBitsApp.Run;
  MDIBitsApp.Done
end.


{--------------------------------------------------------------
  Copyright (c) 1991 by Tom Swan. All rights reserved.
  Revision 1.00    Date: 5/31/1991
---------------------------------------------------------------}